home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Ovlres.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  12.8 KB  |  376 lines  |  [TEXT/R*ch]
  1. open List;
  2. open Fnlib Mixture Const Prim Smlprim Globals Location;
  3. open Units Types Asynt;
  4.  
  5. fun errorOverloadingType loc id tau =
  6. (
  7.   msgIBlock 0;
  8.   errLocation loc;
  9.   errPrompt "Overloaded "; msgString id;
  10.   msgString " cannot be applied to argument(s) of type ";
  11.   printType tau; msgEOL();
  12.   msgEBlock();
  13.   raise Toplevel
  14. );
  15.  
  16. fun errorOverloadingScon loc msg tau =
  17. (
  18.   msgIBlock 0;
  19.   errLocation loc;
  20.   errPrompt ("Overloaded " ^ msg ^ " constant cannot have type ");
  21.   printType tau; msgEOL();
  22.   msgEBlock();
  23.   raise Toplevel
  24. );
  25.  
  26. fun errorConstTooLarge loc msg =
  27. (
  28.   msgIBlock 0;
  29.   errLocation loc;
  30.   errPrompt msg; msgString " constant is too large"; msgEOL();
  31.   msgEBlock();
  32.   raise Toplevel
  33. );
  34.  
  35. val negInt = mkPrimInfo 1 (MLPprim(1, Psmlnegint))
  36. and absInt = mkPrimInfo 1 (MLPccall(1, "sml_abs_int"))
  37. and makestringInt = mkPrimInfo 1 (MLPccall(1, "sml_string_of_int"))
  38. and addInt = mkPrimInfo 1 MLPadd_int
  39. and subInt = mkPrimInfo 1 MLPsub_int
  40. and mulInt = mkPrimInfo 1 MLPmul_int
  41. and divInt = mkPrimInfo 1 MLPdiv_int
  42. and modInt = mkPrimInfo 1 MLPmod_int
  43. and ltInt = mkPrimInfo 1 MLPlt_int
  44. and gtInt = mkPrimInfo 1 MLPgt_int
  45. and leInt = mkPrimInfo 1 MLPle_int
  46. and geInt = mkPrimInfo 1 MLPge_int
  47. ;
  48.  
  49. fun resolveIntOvlId loc "~"    OVL1NNo       = negInt
  50.   | resolveIntOvlId loc "abs"  OVL1NNo       = absInt
  51.   | resolveIntOvlId loc "makestring" OVL1NSo = makestringInt
  52.   | resolveIntOvlId loc "+"    OVL2NNNo      = addInt
  53.   | resolveIntOvlId loc "-"    OVL2NNNo      = subInt
  54.   | resolveIntOvlId loc "*"    OVL2NNNo      = mulInt
  55.   | resolveIntOvlId loc "div"  OVL2NNNo      = divInt
  56.   | resolveIntOvlId loc "mod"  OVL2NNNo      = modInt
  57.   | resolveIntOvlId loc "<"    OVL2NNBo      = ltInt
  58.   | resolveIntOvlId loc ">"    OVL2NNBo      = gtInt
  59.   | resolveIntOvlId loc "<="   OVL2NNBo      = leInt
  60.   | resolveIntOvlId loc ">="   OVL2NNBo      = geInt
  61.   | resolveIntOvlId _   _      _             = fatalError "resolveIntOvlId"
  62. ;
  63.  
  64. val addWord = mkPrimInfo 1 MLPadd_word
  65. and subWord = mkPrimInfo 1 MLPsub_word
  66. and mulWord = mkPrimInfo 1 MLPmul_word
  67. and divWord = mkPrimInfo 1 MLPdiv_word
  68. and modWord = mkPrimInfo 1 MLPmod_word
  69. and ltWord = mkPrimInfo 1 MLPlt_word
  70. and gtWord = mkPrimInfo 1 MLPgt_word
  71. and leWord = mkPrimInfo 1 MLPle_word
  72. and geWord = mkPrimInfo 1 MLPge_word
  73. ;
  74.  
  75. val makestringWord = mkPrimInfo 1 (MLPccall(1, "sml_hexstring_of_word"));
  76.  
  77. fun resolveWordOvlId loc "+"    OVL2NNNo = addWord
  78.   | resolveWordOvlId loc "-"    OVL2NNNo = subWord
  79.   | resolveWordOvlId loc "*"    OVL2NNNo = mulWord
  80.   | resolveWordOvlId loc "div"  OVL2NNNo = divWord
  81.   | resolveWordOvlId loc "mod"  OVL2NNNo = modWord
  82.   | resolveWordOvlId loc "<"    OVL2NNBo = ltWord
  83.   | resolveWordOvlId loc ">"    OVL2NNBo = gtWord
  84.   | resolveWordOvlId loc "<="   OVL2NNBo = leWord
  85.   | resolveWordOvlId loc ">="   OVL2NNBo = geWord
  86.   | resolveWordOvlId loc "makestring" OVL1NSo = makestringWord
  87.   | resolveWordOvlId loc id     _        = 
  88.       errorOverloadingType loc id type_word;
  89.  
  90. (* Temporary implementation of Word8.{+,-,*} operations: *)
  91.  
  92. val addWord8 = mkPrimInfo 1 (MLPgv {qual="Word8", id="+"})
  93. val subWord8 = mkPrimInfo 1 (MLPgv {qual="Word8", id="-"})
  94. val mulWord8 = mkPrimInfo 1 (MLPgv {qual="Word8", id="*"})
  95.  
  96. fun resolveWord8OvlId loc "+"    OVL2NNNo = addWord8
  97.   | resolveWord8OvlId loc "-"    OVL2NNNo = subWord8
  98.   | resolveWord8OvlId loc "*"    OVL2NNNo = mulWord8
  99.   | resolveWord8OvlId loc "div"  OVL2NNNo = divWord
  100.   | resolveWord8OvlId loc "mod"  OVL2NNNo = modWord
  101.   | resolveWord8OvlId loc "<"    OVL2NNBo = ltWord
  102.   | resolveWord8OvlId loc ">"    OVL2NNBo = gtWord
  103.   | resolveWord8OvlId loc "<="   OVL2NNBo = leWord
  104.   | resolveWord8OvlId loc ">="   OVL2NNBo = geWord
  105.   | resolveWord8OvlId loc "makestring" OVL1NSo = makestringWord
  106.   | resolveWord8OvlId loc id     _        = 
  107.       errorOverloadingType loc id type_word8;
  108.  
  109. val makestringChar = mkPrimInfo 1 (MLPccall(1, "sml_makestring_of_char"));
  110.  
  111. fun resolveCharOvlId loc "makestring" OVL1NSo = makestringChar
  112.   | resolveCharOvlId loc "<"    OVL2NNBo = ltInt
  113.   | resolveCharOvlId loc ">"    OVL2NNBo = gtInt
  114.   | resolveCharOvlId loc "<="   OVL2NNBo = leInt
  115.   | resolveCharOvlId loc ">="   OVL2NNBo = geInt
  116.   | resolveCharOvlId loc id     _ =
  117.       errorOverloadingType loc id type_char
  118. ;
  119.  
  120. val negReal = mkPrimInfo 1 (MLPprim(1, Pfloatprim Psmlnegfloat))
  121. and absReal = mkPrimInfo 1 (MLPccall(1, "sml_abs_real"))
  122. and makestringReal = mkPrimInfo 1 (MLPccall(1, "sml_string_of_float"))
  123. and addReal = mkPrimInfo 1 MLPadd_real
  124. and subReal = mkPrimInfo 1 MLPsub_real
  125. and mulReal = mkPrimInfo 1 MLPmul_real
  126. and ltReal = mkPrimInfo 1 MLPlt_real
  127. and gtReal = mkPrimInfo 1 MLPgt_real
  128. and leReal = mkPrimInfo 1 MLPle_real
  129. and geReal = mkPrimInfo 1 MLPge_real
  130. ;
  131.  
  132. fun resolveRealOvlId loc "~"    OVL1NNo  = negReal
  133.   | resolveRealOvlId loc "abs"  OVL1NNo  = absReal
  134.   | resolveRealOvlId loc "makestring" OVL1NSo = makestringReal
  135.   | resolveRealOvlId loc "+"    OVL2NNNo = addReal
  136.   | resolveRealOvlId loc "-"    OVL2NNNo = subReal
  137.   | resolveRealOvlId loc "*"    OVL2NNNo = mulReal
  138.   | resolveRealOvlId loc "<"    OVL2NNBo = ltReal
  139.   | resolveRealOvlId loc ">"    OVL2NNBo = gtReal
  140.   | resolveRealOvlId loc "<="   OVL2NNBo = leReal
  141.   | resolveRealOvlId loc ">="   OVL2NNBo = geReal
  142.   | resolveRealOvlId loc id _ = 
  143.       errorOverloadingType loc id type_real
  144. ;
  145.  
  146. val makestringString = mkPrimInfo 1 (MLPccall(1, "sml_makestring_of_string"))
  147. and ltString = mkPrimInfo 1 MLPlt_string
  148. and gtString = mkPrimInfo 1 MLPgt_string
  149. and leString = mkPrimInfo 1 MLPle_string
  150. and geString = mkPrimInfo 1 MLPge_string
  151. ;
  152.  
  153. fun resolveStringOvlId loc "makestring" OVL1NSo = makestringString
  154.   | resolveStringOvlId loc "<"    OVL2NNBo = ltString
  155.   | resolveStringOvlId loc ">"    OVL2NNBo = gtString
  156.   | resolveStringOvlId loc "<="   OVL2NNBo = leString
  157.   | resolveStringOvlId loc ">="   OVL2NNBo = geString
  158.   | resolveStringOvlId loc id     _ =
  159.       errorOverloadingType loc id type_string
  160. ;
  161.  
  162. val eqInt = mkPrimInfo 1 MLPeq_int
  163. and noteqInt = mkPrimInfo 1 MLPnoteq_int;
  164.  
  165. val eqWord = mkPrimInfo 1 MLPeq_word
  166. and noteqWord = mkPrimInfo 1 MLPnoteq_word;
  167.  
  168. val eqPoly = mkPrimInfo 1 MLPeq
  169. and noteqPoly = mkPrimInfo 1 MLPnoteq;
  170.  
  171. fun resolveOvlId loc id ovltype tau =
  172.   case (ovltype, id) of
  173.       (OVL1TXXo, "printVal") =>
  174.         let val sc = freshSchemeOfType tau in
  175.           mkPrimInfo 1 (MLPgvt({qual="Meta", id="printVal"}, ref (Obj.repr sc)))
  176.         end
  177.     | (OVL1TPUo, "installPP") =>
  178.         let val sc = freshSchemeOfType tau in
  179.           mkPrimInfo 1 (MLPgvt({qual="Meta", id="installPP"}, ref (Obj.repr sc)))
  180.         end
  181.     | (OVL2EEBo, "=") =>
  182.         (case normType tau of
  183.             CONt([], tyname) =>
  184.               if isEqTN tyname tyname_int orelse isEqTN tyname tyname_char then
  185.           eqInt
  186.               else if (isEqTN tyname tyname_word 
  187.                orelse isEqTN tyname tyname_word8) then
  188.           eqWord
  189.           else
  190.           eqPoly
  191.           | _ => 
  192.         eqPoly)
  193.     | (OVL2EEBo, "<>") =>
  194.         (case normType tau of
  195.             CONt([], tyname) =>
  196.               if isEqTN tyname tyname_int 
  197.           orelse isEqTN tyname tyname_char then
  198.           noteqInt
  199.               else if isEqTN tyname tyname_word 
  200.           orelse isEqTN tyname tyname_word8 then
  201.           noteqWord
  202.           else
  203.           noteqPoly
  204.           | _ => 
  205.         noteqPoly)
  206.     | (_,_) =>
  207.         (case normType tau of
  208.             CONt([], tyname) =>
  209.               if (isEqTN tyname tyname_int) then
  210.                 resolveIntOvlId loc id ovltype
  211.               else if (isEqTN tyname tyname_char) then
  212.                 resolveCharOvlId loc id ovltype
  213.               else if (isEqTN tyname tyname_real) then
  214.                 resolveRealOvlId loc id ovltype
  215.               else if (isEqTN tyname tyname_string) then
  216.                 resolveStringOvlId loc id ovltype
  217.               else if (isEqTN tyname tyname_word) then
  218.                 resolveWordOvlId loc id ovltype
  219.               else if (isEqTN tyname tyname_word8) then
  220.                 resolveWord8OvlId loc id ovltype
  221.               else
  222.             errorOverloadingType loc id tau
  223.           | VARt _ => 
  224.           (* OK because "/" is not overloaded on `real' types: *)
  225.           (unify tau type_int;
  226.            resolveIntOvlId loc id ovltype)
  227.       | _ => errorOverloadingType loc id tau);
  228.  
  229. fun resolveWord8OvlScon loc w = 
  230.     if w > 0w255 then errorConstTooLarge loc "Word8.word"
  231.     else ();
  232.  
  233. fun resolveOvlScon loc (scon as WORDscon w, ref (SOME tau)) =
  234.     (case normType tau of
  235.      CONt([], tyname) =>
  236.          if (isEqTN tyname tyname_word) then
  237.          ()
  238.          else if (isEqTN tyname tyname_word8) then
  239.          resolveWord8OvlScon loc w
  240.          else 
  241.          errorOverloadingScon loc "word" tau
  242.        | VARt _ => unify tau type_word
  243.        | _      => errorOverloadingScon loc "word" tau)
  244.   | resolveOvlScon loc (WORDscon w, ref NONE) =
  245.      fatalError "resolveOvlScon"
  246.   | resolveOvlScon _ _ = (); 
  247.  
  248. fun resolve3Dot (loc: Location) fs rho =
  249.   let val (fields, unresolved) = contentsOfRowType rho
  250.       val () =
  251.         if unresolved then
  252.           errorMsg loc "Unresolved record pattern"
  253.         else ();
  254.       val fs' = map (fn (lab,_) => (lab, (loc, WILDCARDpat))) fields
  255.   in fs @ fs' end
  256. ;
  257.  
  258. fun resolveOvlPat (loc, pat') =
  259.   case pat' of
  260.     SCONpat sconInfo => resolveOvlScon loc sconInfo
  261.   | VARpat _ => ()
  262.   | WILDCARDpat => ()
  263.   | NILpat _ => ()
  264.   | CONSpat(_, p) => resolveOvlPat p
  265.   | EXNILpat _ => ()
  266.   | EXCONSpat(_, p) => resolveOvlPat p
  267.   | EXNAMEpat _ => fatalError "resolveOvlPat"
  268.   | REFpat p => resolveOvlPat p
  269.   | RECpat rp =>
  270.       (case !rp of
  271.            RECrp(fs, NONE) =>
  272.              (app_field resolveOvlPat fs;
  273.               rp := TUPLErp(map snd (sortRow fs)))
  274.          | RECrp(fs, SOME rho) =>
  275.              (app_field resolveOvlPat fs;
  276.               rp := TUPLErp(map snd (sortRow (resolve3Dot loc fs rho))))
  277.          | TUPLErp _ => fatalError "resolveOvlPat")
  278.   | VECpat ps => app resolveOvlPat ps
  279.   | PARpat p => resolveOvlPat p
  280.   | INFIXpat _ => fatalError "resolveOvlPat"
  281.   | TYPEDpat(p,t) =>
  282.       resolveOvlPat p
  283.   | LAYEREDpat(p1, p2) =>
  284.       (resolveOvlPat p1; resolveOvlPat p2)
  285. ;
  286.  
  287. fun resolveOvlExp firstpass (loc, exp') =
  288.   case exp' of
  289.     SCONexp sconInfo => 
  290.     if firstpass then resolveOvlScon loc sconInfo else ()
  291.   | VARexp(ref (RESve _)) => ()
  292.   | VARexp(ve as ref (OVLve (ii, ovltype, tau))) =>
  293.       if firstpass then 
  294.       ()
  295.       else
  296.       let val {qualid, info} = ii
  297.           val {qual, id} = qualid
  298.           val pi = resolveOvlId loc id ovltype tau
  299.       in
  300.           #idKind info :=
  301.           { qualid={qual="General", id=id}, info=PRIMik pi };
  302.           ve := RESve ii
  303.       end
  304.   | FNexp mrules =>
  305.       app (resolveOvlMRule firstpass) mrules
  306.   | APPexp(e1, e2) =>
  307.       (resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  308.   | LETexp(dec, body) =>
  309.       (resolveOvlDec firstpass dec; resolveOvlExp firstpass body)
  310.   | RECexp(r as ref (RECre fs)) =>    (* firstpass only *)
  311.       (app_field (resolveOvlExp firstpass) fs;
  312.        if isTupleRow fs then
  313.          r := TUPLEre(map snd fs)
  314.        else ())
  315.   | RECexp(ref (TUPLEre es)) => 
  316.       if firstpass then fatalError "resolveOvlExp" 
  317.       else app (resolveOvlExp firstpass) es
  318.   | VECexp es =>
  319.       app (resolveOvlExp firstpass) es
  320.   | PARexp e =>
  321.       resolveOvlExp firstpass e
  322.   | INFIXexp es  => fatalError "resolveOvlExp"
  323.   | TYPEDexp(e,ty) =>
  324.       resolveOvlExp firstpass e
  325.   | ANDALSOexp(e1, e2) =>
  326.       (resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  327.   | ORELSEexp(e1, e2) =>
  328.       (resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  329.   | HANDLEexp(e, mrules) =>
  330.       (resolveOvlExp firstpass e; app (resolveOvlMRule firstpass) mrules)
  331.   | RAISEexp e =>
  332.       resolveOvlExp firstpass e
  333.   | IFexp(e0, e1, e2) =>
  334.       (resolveOvlExp firstpass e0; resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  335.   | WHILEexp(e1, e2) =>
  336.       (resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  337.   | SEQexp(e1, e2) =>
  338.       (resolveOvlExp firstpass e1; resolveOvlExp firstpass e2)
  339.  
  340. and resolveOvlMRule firstpass (MRule(pats, exp)) =
  341.   (if firstpass then app resolveOvlPat pats else (); 
  342.    resolveOvlExp firstpass exp)
  343.  
  344. and resolveOvlDec firstpass (_, dec') =
  345.   case dec' of
  346.     VALdec (_, (pvbs, rvbs)) =>
  347.       (app (resolveOvlValBind firstpass) pvbs; 
  348.        app (resolveOvlValBind firstpass) rvbs)
  349.   | PRIM_VALdec _ => ()
  350.   | FUNdec _ => fatalError "resolveOvlDec"
  351.   | TYPEdec _ => ()
  352.   | PRIM_TYPEdec _ => ()
  353.   | DATATYPEdec _ => ()
  354.   | ABSTYPEdec(_, _, dec2) =>
  355.       resolveOvlDec firstpass dec2
  356.   | EXCEPTIONdec _ => ()
  357.   | LOCALdec(dec1, dec2) =>
  358.       (resolveOvlDec firstpass dec1; resolveOvlDec firstpass dec2)
  359.   | OPENdec _ => ()
  360.   | EMPTYdec => ()
  361.   | SEQdec(dec1, dec2) =>
  362.       (resolveOvlDec firstpass dec1; resolveOvlDec firstpass dec2)
  363.   | FIXITYdec _ => ()
  364.  
  365. and resolveOvlValBind firstpass (ValBind(pat, exp)) =
  366.   (if firstpass then resolveOvlPat pat else (); 
  367.    resolveOvlExp firstpass exp);
  368.  
  369. (* We perform two passes over the declaration to resolve overloading:
  370.  * Pass 1 resolves overloaded constants (and their default types),
  371.  * Pass 2 resolves overloaded operators (and their default types).
  372.  *)
  373.  
  374. val resolveOvlDec = 
  375.     fn dec => (resolveOvlDec true dec; resolveOvlDec false dec);
  376.